home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Modules / extras0.em.rjb < prev    next >
Lisp/Scheme  |  1992-10-06  |  6KB  |  255 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: extras0.em
  4. ;; Date: Fri Jan 10 04:17:12 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule extras0
  11.   (ccc lists list-operators others arith calls macros0 tables
  12.        (except (null) class-names)
  13.        classes
  14.        symbols
  15.        formatted-io
  16.        generics
  17.        vectors
  18.        strings
  19.        ) ()
  20.  
  21.   (defun not (widget) (null widget))
  22.  
  23.   (export not)
  24.  
  25.   (defun caar (x) (car (car x)))
  26.   (defun cadr (x) (car (cdr x)))
  27.   (defun cdar (x) (cdr (car x)))
  28.   (defun cddr (x) (cdr (cdr x)))
  29.  
  30.   (export caar cadr cdar cddr)
  31.  
  32.   (defun caaar (x) (car (car (car x))))
  33.   (defun caadr (x) (car (car (cdr x))))
  34.   (defun cadar (x) (car (cdr (car x))))
  35.   (defun caddr (x) (car (cdr (cdr x))))
  36.   (defun cdaar (x) (cdr (car (car x))))
  37.   (defun cdadr (x) (cdr (car (cdr x))))
  38.   (defun cddar (x) (cdr (cdr (car x))))
  39.   (defun cdddr (x) (cdr (cdr (cdr x))))
  40.  
  41.   (export caaar caadr cadar caddr cdaar cdadr cddar cdddr)
  42.  
  43.   (defun caaaar (x) (car (car (car (car x)))) )
  44.   (defun caaadr (x) (car (car (car (cdr x)))) )
  45.   (defun caadar (x) (car (car (cdr (car x)))) )
  46.   (defun caaddr (x) (car (car (cdr (cdr x)))) )
  47.   (defun cadaar (x) (car (cdr (car (car x)))) )
  48.   (defun cadadr (x) (car (cdr (car (cdr x)))) )
  49.   (defun caddar (x) (car (cdr (cdr (car x)))) )
  50.   (defun cadddr (x) (car (cdr (cdr (cdr x)))) )
  51.   (defun cdaaar (x) (cdr (car (car (car x)))) )
  52.   (defun cdaadr (x) (cdr (car (car (cdr x)))) )
  53.   (defun cdadar (x) (cdr (car (cdr (car x)))) )
  54.   (defun cdaddr (x) (cdr (car (cdr (cdr x)))) )
  55.   (defun cddaar (x) (cdr (cdr (car (car x)))) )
  56.   (defun cddadr (x) (cdr (cdr (car (cdr x)))) )
  57.   (defun cdddar (x) (cdr (cdr (cdr (car x)))) )
  58.   (defun cddddr (x) (cdr (cdr (cdr (cdr x)))) )
  59.  
  60.   (export caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr 
  61.       cdaaar cdaadr cdadar cdaddr cddaar cdddar cddadr cddddr)
  62.  
  63.   (defun eqcar (a b) (cond ((atom a) nil) ((eq (car a) b) t) (t nil)))
  64.  
  65.   (export eqcar)
  66.  
  67.   (defun mkquote (x) (list 'quote x))
  68.  
  69.   (export mkquote)
  70.  
  71.   (defun assq (a l)
  72.     (cond
  73.      ((null l) nil)
  74.      ((eq a (caar l)) (car l))
  75.      (t (assq a (cdr l)))) )
  76.  
  77.   (export assq)
  78.  
  79.   (defun list-ref (l n)
  80.     (if (equal n 0) (car l)
  81.       (list-ref (cdr l) (\- n 1))))
  82.  
  83.   (export list-ref)
  84.  
  85.   (defun \@list-ref-update\@ (l n obj)
  86.     (if (equal n 0) ((setter car) l obj)
  87.       (\@list-ref-update\@ (cdr l) (- n 1) obj)))
  88.  
  89.   (defun reverse (l)
  90.     (reverse-aux l nil))
  91.  
  92.   (defun reverse-aux (l so-far)
  93.     (if l (reverse-aux (cdr l)
  94.              (cons (car l) so-far))
  95.       so-far))
  96.  
  97.   ;;  (defun reverse (l)
  98.   ;;    (labels ((rev1 (l n)
  99.   ;;           (if (null l) n
  100.   ;;             (rev1 (cdr l) (cons (car l) n)))))
  101.   ;;        (rev1 l nil)))
  102.  
  103.   (export reverse)
  104.  
  105.   (defun subst (a b c)
  106.     (cond
  107.      ((equal c b) a)
  108.      ((atom c) c)
  109.      (t 
  110.       ((lambda (carc cdrc)
  111.      (cond ((and (eq carc (car c)) (eq cdrc (cdr c))) c)
  112.            (t (cons carc cdrc))))
  113.        (subst a b (car c))
  114.        (subst a b (cdr c))))))
  115.  
  116.   (export subst)
  117.  
  118.   (defun delete (a b comp)
  119.     (cond
  120.      ((null b) nil)
  121.      ((comp a (car b)) (cdr b))
  122.      (t ((lambda (del)
  123.        (cond ((eq del (cdr b)) b)
  124.          (t (cons (car b) del))))
  125.      (delete a (cdr b) comp)))))
  126.  
  127.   (export delete)
  128.  
  129.   (defun deleteq (a b)
  130.     (cond
  131.      ((null b) nil)
  132.      ((eq a (car b)) (cdr b))
  133.      (t ((lambda (del)
  134.        (cond ((eq del (cdr b)) b)
  135.          (t (cons (car b) del))))
  136.      (deleteq a (cdr b))))))
  137.  
  138.   (export deleteq)
  139.  
  140.   ;;
  141.   ;; Missing bits...
  142.   ;;
  143.  
  144.   (defun negativep (i) (binary-lt i 0))
  145.  
  146.   (export negativep)
  147.  
  148.   (defun list-copy-aux (l new)
  149.     (if l (list-copy-aux (cdr l) (nconc new (cons (car l) nil)))
  150.       new))
  151.  
  152.   (defun list-copy (l) (list-copy-aux l nil))
  153.  
  154.   (export list-copy)
  155.  
  156.  
  157.   ;; Conversion
  158.   ;; According to the standard (nearly)
  159.  
  160.   (defconstant *convert-tab* (make-table eq))
  161.  
  162.   (defun converter (class)
  163.     (let ((xx (table-ref *convert-tab* class)))
  164.       (if (not (null xx))
  165.       xx
  166.     (let ((new-gen (make-converter-generic class)))
  167.       ((setter converter) class new-gen)
  168.       new-gen))))
  169.       
  170.   (defun make-converter-generic (class)
  171.     (make-instance generic-function
  172.            'name (make-symbol (format nil "~a-converter" (class-name class)))
  173.            'lambda-list '(a)
  174.            'method-class method))
  175.   
  176.   ((setter setter) converter
  177.    (lambda (class fn)
  178.      ((setter table-ref) *convert-tab* class fn)))
  179.   
  180.   
  181.   (defun convert (x class)
  182.     ((converter class) x))
  183.   
  184.   (export converter convert)
  185.   ;; shove in the defined methods...
  186.   ;; Really so trivial that we could use lisp functions...
  187.  
  188.   (add-method (converter vector)
  189.           (make-instance method
  190.                  'signature (list pair)
  191.                  'function generic_generic_convert\,Cons\,Vector))
  192.  
  193.   (add-method (converter pair)
  194.           (make-instance method 
  195.                  'signature (list vector)
  196.                  'function generic_generic_convert\,Vector\,Cons))
  197.  
  198.   (compile-time
  199.    (add-method (converter vector)
  200.            (make-instance method
  201.                  'signature (list (class-of nil))
  202.                  'function 
  203.                  (lambda (c)
  204.                    (make-vector 0))))
  205.  
  206.    (add-method (converter string)
  207.            (make-instance method 
  208.                   'signature (list object)
  209.                   'function (lambda (obj)
  210.                       (format nil "~a" obj))))
  211.    )
  212.  
  213.   (interpret-time
  214.    (add-method (converter vector)
  215.            (make-instance method
  216.                  'signature (list (class-of nil))
  217.                  'function 
  218.                  (lambda (a b c)
  219.                    (make-vector 0))))
  220.  
  221.    (add-method (converter string)
  222.            (make-instance method 
  223.                   'signature (list object)
  224.                   'function (lambda (a b obj)
  225.                       (format nil "~a" obj))))
  226.    )
  227.  
  228.   ;; Also need to add:
  229.   ;; (allsorts) number from string
  230.   ;; char<-->int
  231.   ;; string->pair
  232.  
  233.  
  234.   ;; Changing the habit of a lifetime
  235.   (defconstant length (make-instance generic-function 
  236.                      'name 'length
  237.                      'lambda-list '(l)
  238.                      'method-class method))
  239.  
  240.   (add-method length (make-instance method
  241.                     'signature (list pair)
  242.                     'function list-length))
  243.  
  244.   (add-method length (make-instance method 
  245.                     'signature (list vector)
  246.                     'function vector-length))
  247.  
  248.   (add-method length (make-instance method
  249.                     'signature (list string)
  250.                     'function string-length))
  251.  
  252.   (export length)
  253.  
  254. )
  255.